unit Lingr;

(*
 *   Copyright (c) 2008 Shintaro Akiyama (freeandnil.self@gmail.com)
 *
 *   Redistribution and use in source and binary forms, with or without
 *   modification, are permitted provided that the following conditions
 *   are met:
 *
 *   1. Redistributions of source code must retain the above copyright
 *      notice, this list of conditions and the following disclaimer.
 *
 *   2. Redistributions in binary form must reproduce the above copyright
 *      notice, this list of conditions and the following disclaimer in the
 *      documentation and/or other materials provided with the distribution.
 *
 *   3. Neither the name of the authors nor the names of its contributors
 *      may be used to endorse or promote products derived from this
 *      software without specific prior written permission.
 *
 *   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 *   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 *   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 *   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 *   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 *   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
 *   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 *   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 *   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 *   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 *   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

interface

uses SysUtils, Classes, Contnrs;

type
  TLingrSession = class;
  TLingrChatRoom = class;

  TLingr = class
  private
    FAPIKey: String;
    FSession: TLingrSession;
    FURL: string;
  public
    constructor Create;
    destructor Destroy; override;
    procedure CreateSession;
    procedure DestroySession;
    procedure SetDebugOutput(Strings: TStrings);
    property APIKey: String read FAPIKey write FAPIKey;
    property Session: TLingrSession read FSession;
    property URL: string read FURL write FURL;
  end;

  TLingrSession = class
  private
    FID: WideString;
    FIsOpen: Boolean;
    FAuth: Boolean;
    FChatRooms: TObjectList;
  protected
    procedure AddChatRoom(ChatRoom: TLingrChatRoom);
    procedure RemoveChatRoom(ChatRoom: TLingrChatRoom);
  public
    constructor Create;
    destructor Destroy; override;
    function Veryfy: Boolean;
    procedure Open(const APIKey: string);
    procedure Close;
    procedure Login(const EMail, Password: WideString);
    procedure Logout;
    function EnterChatRoom(const Room, NickName: WideString): TLingrChatRoom;
    procedure ExitAllChatRooms;
    property ID: WideString read FID;
    property IsOpen: Boolean read FIsOpen;
    property Auth: Boolean read FAuth;
    property ChatRooms: TObjectList read FChatRooms;
  end;

  TLingrMessage = class
  private
    FID: WideString;
    FMessageType: WideString;
    FOccupantID: WideString;
    FNickName: WideString;
    FSource: WideString;
    FClientType: WideString;
    FIconUrl: WideString;
    FTimeSTamp: WideString;
    FText: WideString;
  public
    property ID: WideString read FID write FID;
    property MessageType: WideString read FMessageType write FMessageType;
    property OccupantID: WideString read FOccupantID write FOccupantID;
    property NickName: WideString read FNickName write FNickName;
    property Source: WideString read FSource write FSource;
    property ClientType: WideString read FClientType write FClientType;
    property IconUrl: WideString read FIconUrl write FIconUrl;
    property TimeStamp: WideString read FTimeStamp write FTimeStamp;
    property Text: WideString read FText write FText;
  end;

  TLingrOccupant = class
  private
    FID: WideString;
    FNickName: WideString;
    FDescription: WideString;
    FIconUrl: WideString;
    FSource: WideString;
    FClientType: WideString;
  public
    property ID: WideString read FID write FID;
    property NickName: WideString read FNickName write FNickName;
    property Description: WideString read FDescription write FDescription;
    property Source: WideString read FSource write FSource;
    property ClientType: WideString read FClientType write FClientType;
    property IconUrl: WideString read FIconUrl write FIconUrl;
  end;

  TLingrNotifyEvent = procedure(Messages, Occupants: TObjectList) of object;
  TLingrObserveThread = class(TThread)
  private
    FSessionID: WideString;
    FTicket: WideString;
    FCounter: WideString;
    FOnNotify: TLingrNotifyEvent;
    FOnExceptionObserve: TNotifyEvent;
    FRetryInterval: Cardinal;
    FMsgs: TObjectList;
    FOccs: TObjectList;
    FException: Exception;
  protected
    procedure Execute; override;
    procedure SyncNotify;
    procedure SyncExcpetion;
  public
    constructor Create(SessionID, Ticket, Counter: WideString);
    property OnNotify: TLingrNotifyEvent read FOnNotify write FOnNotify;
    property OnExceptionObserve: TNotifyEvent read FOnExceptionObserve write FOnExceptionObserve;
    property RetryInterval: Cardinal read FRetryInterval write FRetryInterval;
  end;

  TLingrChatRoom = class
  private
    FSession: TLingrSession;
    FTicket: WideString;
    FUrl: WideString;
    FDescription: WideString;
    FName: WideString;
    FCounter: WideString;
    FChatterCount: Integer;
    FObserverCount: Integer;
    FIsOpen: Boolean;
    FRetryInterval: Cardinal;
    FObserveThread: TLingrObserveThread;
    FOnExceptionObserve: TNotifyEvent;
  protected
    procedure ThreadTerminate(Sender: TObject);
    procedure SetExceptionObserve(Handle: TNotifyEvent);
  public
    constructor Create(Session: TLingrSession; Room, NickName: WideString);
    destructor Destroy; override;
    procedure Say(const Msg: WideString);
    procedure Observe(NotifyEvent: TLingrNotifyEvent);
    procedure StopObservation;
    procedure ExitRoom;
    property Url: WideString read FUrl;
    property Description: WideString read FDescription;
    property Name: WideString read FName;
    property Count: WideString read FCounter;
    property ChatterCount: Integer read FChatterCount;
    property ObserverCount: Integer read FObserverCount;
    property IsOpen: Boolean read FIsOpen;
    property RetryInterval: Cardinal read FRetryInterval write FRetryInterval;
    property OnExceptionObserve: TNotifyEvent read FOnExceptionObserve write SetExceptionObserve;
  end;

implementation

uses LingrProcedure, LingrResponse, LingrRequest, ActiveX{for MSXML};

{ TLingr }

constructor TLingr.Create;
begin
  FUrl := 'http://www.lingr.com';
  LingrProc.Url := FUrl;
  FSession := TLingrSession.Create;
end;

procedure TLingr.CreateSession;
begin
  FSession.Open(FAPIKey);
end;

destructor TLingr.Destroy;
begin
  FreeAndNil(FSession);
end;

procedure TLingr.DestroySession;
begin
  FSession.Close;
end;


procedure TLingr.SetDebugOutput(Strings: TStrings);
begin
  LingrProc.SetDebugOutput(Strings);
end;

{ TLingrSession }

procedure TLingrSession.AddChatRoom(ChatRoom: TLingrChatRoom);
begin
  if FChatRooms.IndexOf(ChatRoom) = -1 then
    FChatRooms.Add(ChatRoom);
end;

procedure TLingrSession.Close;
var
  Ret: TLingrResponse;
  Data: TLingrRequest;
begin
  if not FIsOpen then Exit;

  ExitAllChatRooms;
  if FAuth then
    Logout;

  Ret := nil;
  Data := nil;
  try
    Ret := TLingrResponse.Create;
    Data := TLingrRequest.Create;
    Data['session'] := FID;
    LingrProc.CallPost('/api/session/destroy/', Data, Ret);
    FIsOpen := False;
  finally
    if Ret <> nil then Ret.Free;
    if Data <> nil then Data.Free;
  end;
end;

constructor TLingrSession.Create;
begin
  inherited Create;
  FIsOpen := False;
  FAuth := False;
  FChatRooms := TObjectList.Create;
  FChatRooms.OwnsObjects := False;
end;

destructor TLingrSession.Destroy;
begin
  if FIsOpen then
    Close;
  FreeAndNil(FChatRooms);

  inherited;
end;

function TLingrSession.EnterChatRoom(const Room, NickName: WideString): TLingrChatRoom;
var
  Chat: TLingrChatRoom;
begin
  Chat := TLingrChatRoom.Create(Self, Room, NickName);
  FChatRooms.Add(Chat);
  Result := Chat;
end;

procedure TLingrSession.ExitAllChatRooms;
var
  i: Integer;
begin
  for i := FChatRooms.Count - 1 downto 0 do begin
    FChatRooms[i].Free;
    FChatRooms.Delete(i);
  end;
end;

procedure TLingrSession.Login(const EMail, Password: WideString);
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  if not FIsOpen or FAuth then Exit;

  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;
    Data['session'] := FID;
    Data['email'] := EMail;
    Data['password'] := Password;
    LingrProc.CallPost('/api/auth/login/', Data, Ret);
    FAuth := True;
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrSession.Logout;
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  if not (FIsOpen and FAuth) then Exit;

  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;
    Data['session'] := FID;
    LingrProc.CallPost('/api/auth/logout/', Data, Ret);
    FAuth := False;
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrSession.Open(const APIKey: string);
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  if FIsOpen then Exit;

  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;
    Data['api_key'] := APIKey;
    LingrProc.CallPost('/api/session/create/', Data, Ret);
    FID := Ret.Xml.DocumentElement.ChildNodes['session'].Text;
    FIsOpen := True;
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrSession.RemoveChatRoom(ChatRoom: TLingrChatRoom);
begin
  FChatRooms.Remove(ChatRoom)
end;

function TLingrSession.Veryfy: Boolean;
begin
  Result := True;
end;

{ TLingrChatRoom }

constructor TLingrChatRoom.Create(Session: TLingrSession; Room, NickName: WideString);
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  FSession := Session;
  FChatterCount := 0;
  FObserverCount := 0;
  FRetryInterval := 60000;
  FIsOpen := False;
  FObserveThread := nil;
  FOnExceptionObserve := nil;

  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;

    Data['session'] := FSession.ID;
    Data['id'] := Room;
    Data['nickname'] := NickName;
    LingrProc.CallPost('/api/room/enter/', Data, Ret);
    FIsOpen := True;
    with Ret.Xml.DocumentElement do begin
      FTicket := ChildNodes['ticket'].Text;
      FUrl := ChildNodes['room'].ChildNodes['url'].Text;
      FName := ChildNodes['room'].ChildNodes['name'].Text;
      FDescription:= ChildNodes['room'].ChildNodes['description'].Text;
      FCounter := ChildNodes['room'].ChildNodes['counter'].Text;
      FChatterCount := StrToInt(ChildNodes['room'].ChildNodes['chatter_count'].Text);
      FObserverCount := StrToInt(ChildNodes['room'].ChildNodes['observer_count'].Text);
    end;
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

destructor TLingrChatRoom.Destroy;
begin
  if FIsOpen then
    ExitRoom;
end;

procedure TLingrChatRoom.ExitRoom;
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  if FObserveThread <> nil then begin
   FObserveThread.Terminate;
   FObserveThread := nil;
  end;
 
  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;

    Data['session'] := FSession.ID;
    Data['ticket'] := FTicket;
    LingrProc.CallPost('/api/room/exit/', Data, Ret);
    FIsOpen := False;
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrChatRoom.Observe(NotifyEvent: TLingrNotifyEvent);
begin
  if FObserveThread = nil then begin
    FObserveThread := TLingrObserveThread.Create(FSession.ID, FTicket, FCounter);
    FObserveThread.OnTerminate := ThreadTerminate;
    FObserveThread.RetryInterval := FRetryInterval;
    FObserveThread.OnNotify := NotifyEvent;
    FObserveThread.OnExceptionObserve := FOnExceptionObserve;
    FObserveThread.Resume;
  end;
end;

procedure TLingrChatRoom.Say(const Msg: WideString);
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
begin
  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;

    Data['session'] := FSession.ID;
    Data['ticket'] := FTicket;
    Data['message'] := Msg;
    LingrProc.CallPost('/api/room/say/', Data, Ret);
  finally
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrChatRoom.SetExceptionObserve(Handle: TNotifyEvent);
begin
  FOnExceptionObserve := Handle;
  if FObserveThread <> nil then
    FObserveThread.OnExceptionObserve := Handle;
end;

procedure TLingrChatRoom.StopObservation;
begin
  FObserveThread.Terminate;
  FObserveThread := nil;
end;

// thread exceptoin
procedure TLingrChatRoom.ThreadTerminate(Sender: TObject);
var
  T: TLingrObserveThread;
  E: Exception;
  Event: TLingrNotifyEvent;
begin
  T := (Sender as TLingrObserveThread);
  if T.FatalException = nil then Exit;
  Event := T.OnNotify;
  E := T.FatalException as Exception;
  if E <> nil then begin
    FObserveThread := nil;
    FOnExceptionObserve(E);
  end;
end;

{ TLingrObserveThread }

constructor TLingrObserveThread.Create(SessionID, Ticket, Counter: WideString);
begin
  inherited Create(True);

  FreeOnTerminate := True;
  FSessionID := SessionID;
  FTicket := Ticket;
  FCounter := Counter;
  FOnNotify := nil;
  FRetryInterval := 60000;
  FOnExceptionObserve := nil;
end;


procedure TLingrObserveThread.Execute;
var
  Data: TLingrRequest;
  Ret: TLingrResponse;
  i: Integer;
  Msg: TLingrMessage;
  Msgs: TObjectList;
  Occ: TLingrOccupant;
  Occs: TObjectList;
begin
  CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
  Data := nil;
  Ret := nil;
  try
    Data := TLingrRequest.Create;
    Ret := TLingrResponse.Create;

    Data['session'] := FSessionID;
    Data['ticket'] := FTicket;
    while not Terminated do begin
      try
        Data['counter'] := FCounter;

        LingrProc.CallGet('/api/room/observe/', Data, Ret);

        if Ret.Xml.DocumentElement.ChildNodes.Count = 1 then Continue;

        FCounter := Ret.Xml.DocumentElement.ChildNodes['counter'].Text;

        Msgs := nil;
        Occs := nil;
        try
          Msgs := TObjectList.Create(True);
          with Ret.Xml.DocumentElement.ChildNodes['messages'] do begin
            for i := 0 to ChildNodes.Count - 1 do begin
              Msg := TLingrMessage.Create;
              Msgs.Add(Msg);
              Msg.ID := ChildNodes[i].ChildNodes['id'].Text;
              Msg.MessageType := ChildNodes[i].ChildNodes['type'].Text;
              Msg.OccupantID := ChildNodes[i].ChildNodes['occupant_id'].Text;
              Msg.NickName := ChildNodes[i].ChildNodes['nickname'].Text;
              Msg.Source := ChildNodes[i].ChildNodes['source'].Text;
              Msg.ClientType := ChildNodes[i].ChildNodes['client_type'].Text;
              Msg.IconUrl := ChildNodes[i].ChildNodes['icon_url'].Text;
              Msg.TimeStamp := ChildNodes[i].ChildNodes['timestamp'].Text;
              Msg.Text := ChildNodes[i].ChildNodes['text'].Text;
            end;
          end;
          Occs := TObjectList.Create(True);
          with Ret.Xml.DocumentElement.ChildNodes['occupants'] do begin
            for i := 0 to ChildNodes.Count - 1 do begin
              Occ := TLingrOccupant.Create;
              Occs.Add(Occ);
              Occ.ID := ChildNodes[i].ChildNodes['id'].Text;
              Occ.NickName := ChildNodes[i].ChildNodes['nickname'].Text;
              Occ.Description := ChildNodes[i].ChildNodes['description'].Text;
              Occ.IconUrl := ChildNodes[i].ChildNodes['icon_url'].Text;
              Occ.Source := ChildNodes[i].ChildNodes['source'].Text;
              Occ.ClientType := ChildNodes[i].ChildNodes['client_type'].Text;
            end;
          end;
          FMsgs := Msgs;
          FOccs := Occs;
          try
            Synchronize(SyncNotify);
          finally
            FMsgs := nil;
            FOccs := nil;
          end;
        finally
          if Msgs <> nil then Msgs.Free;
          if Occs <> nil then Occs.Free;
        end;
      except
        on E: Exception do begin
          FException := E;
          Synchronize(SyncExcpetion);
          Sleep(FRetryInterval);
        end;
      end;
    end;
  finally
    CoUninitialize;
    if Data <> nil then Data.Free;
    if Ret <> nil then Ret.Free;
  end;
end;

procedure TLingrObserveThread.SyncExcpetion;
begin
  try
    if Assigned(FOnExceptionObserve) then FOnExceptionObserve(FException);
  except
    // no handling
  end;
end;

procedure TLingrObserveThread.SyncNotify;
begin
  if Assigned(FOnNotify) then FOnNotify(FMsgs, FOccs);
end;

end.
